home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / aegis_port.t < prev    next >
Text File  |  1988-02-05  |  7KB  |  204 lines
  1. (herald aegis_port
  2.         (env tsys (osys vm_port) (osys buffer)))
  3.  
  4. ;;; The Aegis interface to the file system.
  5.  
  6. ;;; Where possible we use IOS calls rather than say NAME calls,
  7. ;;; so that T takes advantage of Extensible ports.
  8. ;;; Random file routines
  9.  
  10. ;;; Returns true if the file exists, otherwise false.
  11.  
  12. ;;; If the file exists VM-FILE-PROBE returns the truename of the
  13. ;;; file, otherwise, it returns false.
  14.  
  15. (define (FILE-PROBE filespec)
  16.   (with-open-ports ((iob (maybe-open filespec 'inquire)))
  17.     (if iob (expand-filename iob) '#f)))
  18.  
  19. (define (expand-filename filespec)
  20.   (with-open-ports ((iob (maybe-open filespec 'inquire)))
  21.     (if iob (->filename (port-truename iob)) (->filename filespec))))
  22.  
  23. (define port-truename
  24.   (lambda (iob)
  25.     (let ((out-buf (get-string-buffer-of-size name_$pnamelen_max)))
  26.       (receive (out-len status)
  27.                (ios_$inq_name (iob-channel iob) out-buf nil nil)
  28.         (check-status status)
  29.         (set (string-length out-buf) out-len)
  30.         (let ((val (copy-string out-buf)))
  31.           (release-string-buffer out-buf)
  32.           val)))))
  33.  
  34. (define-foreign ios_$inq_name
  35.   ("IOS_$INQ_NAME" (in     rep/integer-16-u port-id)
  36.                  (ignore rep/string       out-name)
  37.                  (out    rep/integer-16-u out-len)
  38.                  (out    rep/integer      status))
  39.                 ignore)
  40.  
  41. (define (FILE-MOVE FROM TO)
  42.   (let* ((from   (open-port from 'inquire))
  43.          (to     (->pathname to))
  44.          (to-len (pathname-length to)))
  45.     (check-status (ios_$change_name from to to-len nil))
  46.     (close-port from)
  47.     (release-buffer from)
  48.     (no-value)))
  49.  
  50. (define-foreign ios_$change_name
  51.   ("IOS_$CHANGE_NAME" (in  rep/integer-16-u port-id)
  52.                     (in  rep/string       new-name)
  53.                     (in  rep/integer-16-u new-namelength)
  54.                     (out rep/integer      status))
  55.                 ignore)
  56.  
  57. (define (FILE-DELETE FILESPEC)
  58.   (let ((iob (open-port filespec 'inquire)))
  59.     (ios_$delete (iob-channel iob) nil)
  60.     (close-port iob)
  61.     (release-buffer iob))
  62.   (no-value))
  63.  
  64. (define-foreign ios_$delete
  65.   ("IOS_$DELETE" (in  rep/integer-16-u port-id)
  66.                (out rep/integer      status))
  67.                 ignore)
  68.  
  69. (define (FILE-TRUNCATE iob SIZE)
  70.   (%vm-write-buffer iob)
  71.   ;++ seek to size position
  72.   (check-status (ios_$truncate (iob-channel iob) nil))
  73.   (no-value))
  74.  
  75. (define-foreign ios_$truncate
  76.   ("IOS_$TRUNCATE" (in  rep/integer-16-u port-id)
  77.                  (out rep/integer      status))
  78.                 ignore)
  79.  
  80. ;;; In the next five calls SPEC can be either a filespec or an iob.
  81. ;;; If they cannot be implemented they should return nil.
  82.  
  83. (define (FILE-CREATION-DATE spec)
  84.   (receive (dtc #f #f #f)
  85.            (file-attributes spec)
  86.     dtc))
  87.  
  88. (define (FILE-WRITE-DATE SPEC)
  89.   (receive (#f dtm #f #f)
  90.            (file-attributes spec)
  91.     dtm))
  92.  
  93. (define (FILE-USED-DATE SPEC)
  94.   (receive (#f #f dtu #f)
  95.            (file-attributes spec)
  96.     dtu))
  97.  
  98. (define (FILE-NEWER? SPEC1 SPEC2)
  99.   (fx> (file-write-date spec1)
  100.        (file-write-date spec2)))
  101.  
  102. ;++ is this useful? as is?
  103. (define (FILE-LENGTH SPEC)
  104.     (receive (#f #f #f blocks)
  105.              (file-attributes spec)
  106.       (fx* 1024 blocks)))
  107.  
  108. (define (file-attributes spec)
  109.   (let ((iob (if (iob? spec) spec (open-port spec 'inquire))))
  110.     (receive (dtc dtm dtu blocks status) (iob-attributes iob)
  111.       (check-status status)
  112.       (cond ((not (iob? spec))
  113.              (close-port iob)
  114.              (release-buffer iob)))
  115.       (return dtc dtm dtu blocks))))
  116.  
  117. (define (iob-attributes iob)
  118.   (receive (dtc dtm dtu blocks status)
  119.            (ios_$inq_file_attr (iob-channel iob) nil nil nil nil nil)
  120.     (check-status status)
  121.     (return dtc dtm dtu blocks status)))
  122.  
  123. (define-foreign ios_$inq_file_attr
  124.   ("IOS_$INQ_FILE_ATTR" (in   rep/integer-16-u port-id)
  125.                       (out  rep/integer      dt-created)
  126.                       (out  rep/integer      dt-modified)
  127.                       (out  rep/integer      dt-used)
  128.                       (out  rep/integer      blocks)
  129.                       (out  rep/integer      status))
  130.     ignore)
  131.  
  132. (define-unimplemented (FILE-DIRECTORY? FILESPEC))
  133.  
  134. (define-foreign ios_$inq_type_uid
  135.   ("IOS_$INQ_TYPE_UID" (in     rep/integer-16-u port-id)
  136.                      (ignore rep/extend       type-uid)
  137.                      (out    rep/integer      status))
  138.     ignore)
  139.  
  140.  
  141. ;;; Working directory
  142.  
  143. (define WORKING-DIRECTORY
  144.   (let ((buf (make-string name_$pnamelen_max)))
  145.     (object (lambda ()
  146.               (defer-interrupts
  147.                (receive (length status)
  148.                         (name_$get_wdir buf nil nil)
  149.                  (cond ((fxN= 0 status) '#f)
  150.                        (else
  151.                         (set (string-length buf) length)
  152.                         (->filename buf))))))
  153.       ((setter self)
  154.        (lambda (filespec)
  155.          (let* ((path (->pathname filespec))
  156.                 (len  (pathname-length path)))
  157.            (check-status (name_$set_wdir path len nil))
  158.            (no-value)))))))
  159.  
  160. ;++ change these to ios calls
  161. (define-foreign name_$get_wdir
  162.   ("NAME_$GET_WDIR" (ignore rep/string       name)
  163.                   (out    rep/integer-16-u name-length)
  164.                   (out    rep/integer      status))
  165.                 ignore)
  166.  
  167. (define-foreign name_$set_wdir
  168.   ("NAME_$SET_WDIR" (in  rep/string       name)
  169.                   (in  rep/integer-16-u name-length)
  170.                   (out rep/integer      status))
  171.                 ignore)
  172.  
  173. (define NAMING-DIRECTORY
  174.   (let ((buf (make-string name_$pnamelen_max)))
  175.     (object (lambda ()
  176.               (defer-interrupts
  177.                (receive (length status)
  178.                         (name_$get_ndir buf nil nil)
  179.                 (cond ((fxN= 0 status) '#f)
  180.                       (else
  181.                        (set (string-length buf) length)
  182.                        (->filename buf))))))
  183.       ((setter self)
  184.        (lambda (filespec)
  185.          (let* ((path (->pathname filespec))
  186.                 (len   (pathname-length path)))
  187.            (check-status (name_$set_ndir path len nil))
  188.            (no-value)))))))
  189.  
  190. ;++ change these to ios calls
  191. (define-foreign name_$get_ndir
  192.   ("NAME_$GET_NDIR" (ignore rep/string       name)
  193.                   (out    rep/integer-16-u name-length)
  194.                   (out    rep/integer      status))
  195.                 ignore)
  196.  
  197. (define-foreign name_$set_ndir
  198.   ("NAME_$SET_NDIR" (in  rep/string       name)
  199.                   (in  rep/integer-16-u name-length)
  200.                   (out rep/integer      status))
  201.                 ignore)
  202.  
  203. (define-unimplemented (home-directory))
  204.